Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-04/uldial.zip/ULROOT.PAS

Pascal/Delphi Source File | 1990-07-12 | 16KB | 479 lines

(***********************************************************************
     General Ojbects as Enhancements to Turbo Power OOP Professional
                  New Communications Technology, Inc.
                             Version 1.0
                          by John Poindexter
                             June 1, 1990
************************************************************************)
{$I ULDEFINE.INC}

{$IFNDEF roDEBUG}
{$A-,B-,E+,F+,I+,N-,O+,R-,S-,V-}
{$ELSE}
{$A-,B-,E+,F+,I+,N-,O+,R+,S+,V-}
{$ENDIF}

Unit ULRoot;

Interface

Uses OpRoot, OpCrt, OpColor, OpMouse, OpInline, OpString, OpCmd,
     OpFrame, OpWindow, OpPick, OpField, OpEntry, OpKey;

const
  ucULRoot  = 200;
  ucULDial  = 201;
  ucULData  = 202;
  ucULDbase = 203;

  epNoError = etNoError * 10000;

{ Error Numbers and Messages }
{ Format of this area between ErrorStrs and EndErrorStrs is critical. }
{ Must alternate error code numbers and strings. This area may be }
{ searched to find error messages. }
const ErrorStrs             : byte = 1;  { beginning of string storage }
      ecTooManyKeys         = 3001;
const emTooManyKeys         : string[13] = 'Too many keys';
      ecNoLists             = 3002;
const emNoLists             : string[24] = 'Desc or Key Lists failed';
      ecKeyTooLong          = 3003;
const emKeyTooLong          : string[15] = 'Key is too long';
      ecInvalidDbaseNum     = 3004;
const emInvalidDbaseNum     : string[31] = 'Requested Dbase not initialized';
      ecInvalidIndex        = 3005;
const emInvalidIndex        : string[33] = 'Invalid index for data descriptor';
      ecNoVRecBuf           = 3006;
const emNoVRecBuf           : string[34] = 'VRec buffer too small or no memory';
      ecRebuildReq          = 3007;
const emRebuildReq          : string[38] = 'Index is damaged. Select Ok to rebuild';
      ecTooManyVar          = 3008;
const emTooManyVar          : string[36] = 'May only use 1 variable length field';
      ecDuplicateKeys       = 3009;
const emDuplicateKeys       : string[32] = 'You have entered a duplicate key';
      ecNoChoice            = 3010;
const emNoChoice            : string[23] = 'DialogBox has no choice';
      ecIgnoreChanges       = 3011;
const emIgnoreChanges       : string[30] = 'You made changes. Record them?';
      ecLockNoAccess        = 3012;
const emLockNoAccess        : string[22] = 'A lock prevents access';
      ecFileInUse           = 3013;
const emFileInUse           : string[28] = 'The file is presently in use';
      ecNoReadRec           = 3014;
const emNoReadRec           : string[34] = 'Record could not be read from disk';
      ecRecChanged          = 3015;
const emRecChanged          : string[23] = 'Record has been changed';
      ecRecDeleted          = 3016;
const emRecDeleted          : string[23] = 'Record has been deleted';
      ecNoWordField         = 3017;
const emNoWordField         : string[43] = 'Field preceding variable field must be word';
      ecCreateIFB           = 3018;
const emCreateIFB           : string[41] = 'Data file does not exist. Create new one?';
      ecDupFileName         = 3019;
const emDupFileName         : string[45] = 'Data file exists and will overwrite. Proceed?';
      ecInvalidWSNr         = 3020;
const emInvalidWSNr         : string[26] = 'Invalid WorkStation number';
      ecInitSemaFail        = 3021;
const emInitSemaFail        : string[32] = 'Initialization Semaphores failed';
      ecNoRecords           = 3022;
const emNoRecords           : string[30] = 'There are no records. Add one?';
      ecConfirmDel          = 3023;
const emConfirmDel          : string[30] = 'Prepared to delete this record';
      ecConfirmTagDel       = 3024;
const emConfirmTagDel       : string[37] = 'Prepared to delete all tagged records';
      ecNoMatching          = 3025;
const emNoMatching          : string[24] = 'No matching record found';
      ecOkToFilter          = 3026;
const emOkToFilter          : string[28] = 'Ok to filter with this data?';
      ecQuitBrowse          = 3027;
const emQuitBrowse          : string[14] = 'Quit Browsing?';
      ecTagsNotFirst        = 3028;
const emTagsNotFirst        : string[29] = 'Tag field must be first added';
      ecTagTooShort         = 3029;
const emTagTooShort         : string[47] = 'Tag field too short for number of work stations';
const emISAM                : string[4]  = 'ISAM';
const emStatusHandlerFail   : string[21] = 'Status Handler failed';
const emPossibleRecovery    : string[35] = 'Recovery may be possible with Retry';

const mmAnyKeytoContinue    : string[27] = ' Press any key to continue ';

const EndErrorStrs          : byte = 0;

const
{ Help Indices }
  hiChangeDisplay       = 1;
  hiSearch              = 2;
  hiDialogBox           = 3;

  ULColorSet : ColorSet = (
    TextColor       : BlackonLtGray; TextMono       : $07;
    CtrlColor       : WhiteonBlue;   CtrlMono       : $07;
    FrameColor      : YellowonBlue;  FrameMono      : $0F;
    HeaderColor     : YellowonBlue;  HeaderMono     : $0F;
    ShadowColor     : LtGrayonBlack;  ShadowMono     : $07;
    HighlightColor  : WhiteonRed;    HighlightMono  : $70;
    PromptColor     : BlackonLtGray; PromptMono     : $07;
    SelPromptColor  : BlackonLtGray; SelPromptMono  : $07;
    ProPromptColor  : BlueonLtGray;  ProPromptMono  : $07;
    FieldColor      : BlackonLtGray; FieldMono      : $0F;
    SelFieldColor   : WhiteonBlue;   SelFieldMono   : $70;
    ProFieldColor   : BlueonLtGray;  ProFieldMono   : $07;
    ScrollBarColor  : YellowonBlue;  ScrollBarMono  : $07;
    SliderColor     : YellowonBlue;  SliderMono     : $07;
    HotSpotColor    : WhiteonCyan;   HotSpotMono    : $07;
    BlockColor      : WhiteonBlue;   BlockMono      : $0F;
    MarkerColor     : YellowonLtGray;MarkerMono     : $70;
    DelimColor      : BlackonLtGray; DelimMono      : $0F;
    SelDelimColor   : WhiteonBlue;   SelDelimMono   : $70;
    ProDelimColor   : BlueonLtGray;  ProDelimMono   : $07;
    SelItemColor    : WhiteonRed;    SelItemMono    : $70;
    ProItemColor    : BrownonLtGray; ProItemMono    : $01;
    HighItemColor   : WhiteonRed;    HighItemMono   : $0F;
    AltItemColor    : BlueonLtGray;  AltItemMono    : $0F;
    AltSelItemColor : LtBlueonLtGray;AltSelItemMono : $70;
    FlexAHelpColor  : WhiteonLtGray; FlexAHelpMono  : $0F;
    FlexBHelpColor  : YellowOnRed;   FlexBHelpMono  : $01;
    FlexCHelpColor  : GreenonBlack;  FlexCHelpMono  : $70;
    UnselXrefColor  : YellowonBlack; UnselXrefMono  : $09;
    SelXrefColor    : WhiteonRed;    SelXrefMono    : $70;
    MouseColor      : WhiteonRed;    MouseMono      : $70
  );

  WindowStep : byte = 1;

var
  ULRootColorSet : ColorSet;
  HeadFootAttr : byte;

type

(************************************************************************
  The IndexDblList object desends from DoubleList and adds a GET method
  to return a pointer to the nth node.
************************************************************************)

  IndexDblListPtr = ^IndexDblList;
  IndexDblList = object(DoubleList)
    function Get(Index: word): DoubleNodePtr; virtual;
  end;

(************************************************************************
  The MStringArray descends from StringArray and adds a data field and
  methods for determining and getting the max string length in the array.
  For this to function you must use AddMString vice AddString.
************************************************************************)

  MStringArrayPtr = ^MStringArray;
  MStringArray = object(StringArray)
    msMaxLen : byte;
    constructor Init(Num, Amount: word);
    function AddMString(St : string): word;
    function GetMaxLen: byte;
  end;

(************************************************************************
  Global Routines
************************************************************************)

{$IFDEF UseAdjustableWindows}
procedure MoveCmdWindow(WP: CommandWindowPtr);
procedure ResizeCmdWindow(WP: CommandWindowPtr);
procedure ToggleZoom(WP: CommandWindowPtr);
{$ENDIF}
function IncPtr(P: pointer; W: word): pointer;
function GetGoodCoord(first, wide, maxwide: byte): byte;
function Extend(S : String; Len : Byte) : String;
procedure SimpStatus(UnitCode:byte; var Code: word; Msg:string);
function Center1(OuterWidth, InnerWidth: word): word;
function Coord2(FirstCoord, InnerWidth: word): word;
procedure InitCrt;
procedure RestoreCrt;
procedure Abort;
procedure WriteFooter(Prompt : String);
function SizeOfObject(TypOf: pointer): word;
procedure PromoteAncestor(Ancestor, TypOf: pointer);
procedure NullConversion(EFP: EntryFieldPtr; PostEdit: boolean);

(***********************************************************************)
Implementation
(***********************************************************************)

{$IFDEF UseAdjustableWindows}

procedure MoveCmdWindow(WP: CommandWindowPtr);
  {-Move any window interactively}
var
  Finished : Boolean;
begin
  if WP^.IsZoomed then
    Exit;
  WriteFooter(' Use cursor keys to move, {Enter} to accept');
  Finished := False;
  with WP^ do
    repeat
      case ReadKeyWord of
        $4700 : MoveWindow(-WindowStep, -WindowStep); {Home}
        $4800 : MoveWindow(0, -WindowStep);           {Up arrow}
        $4900 : MoveWindow(WindowStep, -WindowStep);  {PgUp}
        $4B00 : MoveWindow(-WindowStep, 0);           {Left Arrow}
        $4D00 : MoveWindow(WindowStep, 0);            {Right Arrow}
        $4F00 : MoveWindow(-WindowStep, WindowStep);  {End}
        $5000 : MoveWindow(0, WindowStep);            {Down arrow}
        $5100 : MoveWindow(WindowStep, WindowStep);   {PgDn}
        $1C0D : Finished := True;                     {Enter}
      end;

      if ClassifyError(GetLastError) = etFatal then
        Abort;
    until Finished;

  WriteFooter('');
end;

procedure ResizeCmdWindow(WP: CommandWindowPtr);
  {-Resize any window interactively}
var
  Finished : Boolean;
begin
  if WP^.IsZoomed then
    Exit;
  WriteFooter(' Use cursor keys to resize, {Enter} to accept');
  Finished := False;
  with WP^ do
    repeat
      case ReadKeyWord of
        $4700 : ResizeWindow(-WindowStep, -WindowStep); {Home}
        $4800 : ResizeWindow(0, -WindowStep);           {Up}
        $4900 : ResizeWindow(WindowStep, -WindowStep);  {PgUp}
        $4B00 : ResizeWindow(-WindowStep, 0);           {Left}
        $4D00 : ResizeWindow(WindowStep, 0);            {Right}
        $4F00 : ResizeWindow(-WindowStep, WindowStep);  {End}
        $5000 : ResizeWindow(0, WindowStep);            {Down}
        $5100 : ResizeWindow(WindowStep, WindowStep);   {PgDn}
        $1C0D : Finished := True;                       {Enter}
      end;

      if ClassifyError(GetLastError) = etFatal then
        Abort;
    until Finished;

  WriteFooter('');
end;

procedure ToggleZoom(WP: CommandWindowPtr);
  {-Toggle zoom status of any window}
begin
  with WP^ do begin
    if IsZoomed then
      Unzoom
    else
      Zoom;

    if ClassifyError(GetLastError) = etFatal then
      Abort;
  end;
end;
{$ENDIF}

function IncPtr(P: pointer; W: word): pointer;
begin
  IncPtr := AddWordToPtr(Normalized(P), W)
end;

function GetGoodCoord(first, wide, maxwide: byte): byte;
  {adjusts first coordinate if necessary so that a display will fit on screen}
var
  i,j : integer;
begin
  i := first - 1 + wide;
  if i > Succ(maxwide) then
  begin
    i := i - Succ(maxwide);
    j := first - i;
    if j < 2 then GetGoodCoord := 2
    else GetGoodCoord := j;
  end
  else GetGoodCoord := first;
end;

function Extend(S : String; Len : Byte) : String;
  {-Pad or truncate string to specified length}
var
  SLen : Byte absolute S;
begin
  if SLen >= Len then begin
    SLen := Len;
    Extend := S;
  end
  else
    Extend := Pad(S, Len);
end;

const
  SavedState : boolean = false;

var
  (* Various Crt parameters that are saved for later restoration *)
  SaveAttr : byte;
  SaveChar : char;
  SaveXY, SaveScanLines : word;
  SaveMode : byte;
  SaveDir : string[64];
  SaveBreak, SaveEOF : boolean;
  {$IFDEF UseMouse}
  MouseState : boolean;
  {$ENDIF}

(* Initializes Crt and Save parameters *)
procedure InitCrt;
begin
  GetDir(0,SaveDir);
  GetCursorState(SaveXY, SaveScanlines);
  SaveBreak := CheckBreak;
  SaveEOF := CheckEOF;
  ReInitCrt;
  SaveMode := LastMode;
  SaveAttr := ReadAttrAtCursor;
  SaveChar := ReadCharAtCursor;
  SavedState := true;
  {$IFDEF UseMouse}
  if MouseInstalled then HideMousePrim(MouseState);
  {$ENDIF}
end;

(* Restores Global Parameters to their original *)
procedure RestoreCrt;
begin
  {$IFDEF UseMouse}
  if MouseInstalled then ShowMousePrim(MouseState);
  {$ENDIF}
  ChDir(SaveDir);
  RestoreCursorState(SaveXY, SaveScanlines);
  CheckBreak := SaveBreak;
  CheckEOF := SaveEOF;
  TextMode(SaveMode);
  TextAttr := SaveAttr;
  TextChar := SaveChar;
  ClrScr;
end;

(* Centering Functions *)
function Center1(OuterWidth, InnerWidth: word): word;
begin
  Center1 := (OuterWidth - InnerWidth) div 2 + 1;
end;

function Coord2(FirstCoord, InnerWidth: word): word;
begin
  Coord2 := FirstCoord + InnerWidth - 1;
end;

(* Simple Status and Error Handler *)
procedure SimpStatus(UnitCode:byte; var Code: word; Msg:string);
begin
  RingBell;
  WriteLn(Msg, 'Unit: ',UnitCode,' Error: ',Code);
end;

(* MStringArray Methods *)
constructor MStringArray.Init(Num, Amount: word);
begin
  StringArray.Init(Num, Amount);
  msMaxLen := 0;
end;

function MStringArray.AddMString(St : string): word;
var
  Len : byte absolute St;
  Index : word;
begin
  Index := AddString(St);
  if Index <> 0 then msMaxLen := MaxWord(msMaxLen, Len);
  AddMString := Index;
end;

function MStringArray.GetMaxLen: byte;
begin
  GetMaxLen := msMaxLen;
end;

(* IndexDblList Methods *)
function IndexDblList.Get(Index: word): DoubleNodePtr;
var i : word;
    p : DoubleNodePtr;
begin
  if Index > Size then
  begin
    Get := nil;
    Exit;
  end;
  p := Head;
  for i := 2 to Index do p := Next(p);
  Get := p;
end;

(*********************)

procedure Abort;
  {-Abort the program with an out-of-memory error message}
begin
  if SavedState then RestoreCrt
  else
  begin
    NormalCursor;
    ClrScr;
  end;
  WriteLn('Insufficient memory available to continue.');
  Halt(1);
end;

procedure WriteFooter(Prompt : String);
  {-Write a footer on the menu line}
{$IFDEF UseMouse}
var
  SaveMouse : Boolean;
{$ENDIF}
begin
  {$IFDEF UseMouse}
  HideMousePrim(SaveMouse);
  {$ENDIF}

  FastWrite(Extend(Prompt, ScreenWidth), ScreenHeight, 1, HeadFootAttr);
  GotoXYabs(Length(Prompt)+2, ScreenHeight);

  {$IFDEF UseMouse}
  ShowMousePrim(SaveMouse);
  {$ENDIF}
end;

function SizeOfObject(TypOf: pointer): word;
  { TypOf must have been returned by the TypeOf function which returns the
    address of the VMT. The first word of the VMT is the size of the instance.}
begin
  SizeOfObject := word(TypOf^);
end;

procedure PromoteAncestor(Ancestor, TypOf: pointer);
  { This only works if the VMT link is the first two bytes of the ancestor
    as in descendants of Root and TypOf has been returned by
    TypeOf(Descendant). Otherwise it most probably will cause a crash! }
var
  VMTOfs : word;
begin
  VMTOfs := Word(PtrDiff(Ptr(DSeg,0),TypOf));
  Move(VMTOfs, Ancestor^, 2);  {fixup VMT link}
end;

procedure NullConversion(EFP: EntryFieldPtr; PostEdit: boolean);
  { a dummy procedure that should never be called }
begin
  Abstract;
end;

(*******************************)
begin
  ULRootColorSet := ULColorSet;
  with ULRootColorSet do
  HeadFootAttr := ColorMono(HighLightColor, HighLightMono);
End.